home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _679f3c4218a060764376bf03acecd78c < prev    next >
Encoding:
Text File  |  2002-05-30  |  3.9 KB  |  151 lines
  1. package Tk::DragDrop::XDNDSite;
  2. use strict;
  3. use vars qw($VERSION);
  4. $VERSION = '3.010'; # $Id: //depot/Tk8/DragDrop/DragDrop/XDNDSite.pm#10 $
  5. use base qw(Tk::DropSite);
  6.  
  7. sub XDND_PROTOCOL_VERSION () { 3 }
  8.  
  9. Tk::DropSite->Type('XDND');
  10.  
  11. sub InitSite
  12. {my ($class,$site) = @_;
  13.  my $w = $site->widget;
  14. }
  15.  
  16. sub XdndEnter
  17. {
  18.  my ($t,$sites) = @_;
  19.  my $event = $t->XEvent;
  20.  my ($src,$flags,@types) = unpack('LLLLL',$event->A);
  21.  # print "XdndEnter $src\n";
  22.  my $ver = ($flags >> 24) & 0xFF;        
  23.  if ($flags & 1)
  24.   {
  25.    my @prop;
  26.    Tk::catch { @prop = $t->property('get','XdndTypeList',$src) };
  27.    @types = @prop if (!$@ && shift(@prop) eq 'ATOM');
  28.   }
  29.  $t->{"XDND$src"} = { ver => $ver, types => \@types };
  30. }
  31.  
  32. sub XdndLeave
  33. {
  34.  my ($t,$sites) = @_;
  35.  my $event = $t->XEvent;
  36.  my ($src,$flags,@types) = unpack('LLLLL',$event->A);
  37.  # print "XdndLeave $src\n";
  38.  my $info = $t->{"XDND$src"};
  39.  if ($info)
  40.   {
  41.    my $over = $info->{site};
  42.    if ($over)
  43.     {   
  44.      my $X = $info->{X};
  45.      my $Y = $info->{Y};
  46.      $over->Apply(-entercommand => $X, $Y, 0) 
  47.     }
  48.   }
  49.  delete $t->{"XDND$src"};
  50. }
  51.  
  52. sub XdndPosition
  53. {
  54.  my ($t,$sites) = @_;
  55.  my $event = $t->XEvent;
  56.  my ($src,$flags,$xy,$time,$action) = unpack('LLLLL',$event->A);
  57.  my $X = $xy >> 16;
  58.  my $Y = $xy & 0xFFFF;
  59.  my $info = $t->{"XDND$src"};
  60.  $info->{X}      = $X;
  61.  $info->{Y}      = $Y;
  62.  $info->{action} = $action;
  63.  $info->{t}      = $time;
  64.  my $id    = oct($t->id);
  65.  my $sxy   = 0; 
  66.  my $swh   = 0; 
  67.  my $sflags = 0;
  68.  my $saction = 0;
  69.  my $over = $info->{site};
  70.  foreach my $site (@$sites)
  71.   {
  72.    if ($site->Over($X,$Y))
  73.     {
  74.      $sxy = ($site->X << 16)     | $site->Y;    
  75.      $swh = ($site->width << 16) | $site->height;
  76.      $saction = $action;                        
  77.      $sflags |= 1;                              
  78.      if ($over)                                 
  79.       {                                         
  80.        if ($over == $site)                      
  81.         {                                       
  82.          $site->Apply(-motioncommand => $X, $Y);
  83.         }                                       
  84.        else                                     
  85.         {                                       
  86.          $over->Apply(-entercommand => $X, $Y, 0);
  87.          $site->Apply(-entercommand => $X, $Y, 1);
  88.         }                                       
  89.       }                                         
  90.      else                                       
  91.       {                                         
  92.        $site->Apply(-entercommand => $X, $Y, 1);
  93.       }     
  94.      $info->{site} = $site;                     
  95.      last;
  96.     }
  97.   }
  98.  unless ($sflags & 1)
  99.   {
  100.    if ($over)
  101.     {
  102.      $over->Apply(-entercommand => $X, $Y, 0) 
  103.     }
  104.    delete $info->{site};
  105.   }
  106.  my $data = pack('LLLLL',$id,$sflags,$sxy,$swh,$action);
  107.  $t->SendClientMessage('XdndStatus',$src,32,$data);
  108. }
  109.  
  110. sub XdndDrop
  111. {
  112.  my ($t,$sites) = @_;
  113.  my $event = $t->XEvent;
  114.  my ($src,$flags,$time,$res1,$res2) = unpack('LLLLL',$event->A);
  115.  my $info   = $t->{"XDND$src"};        
  116.  my $sflags = 0;
  117.  if ($info)
  118.   {         
  119.    $info->{t} = $time;
  120.    my $site = $info->{'site'};
  121.    if ($site)
  122.     {
  123.      my $X = $info->{'X'};                  
  124.      my $Y = $info->{'Y'};                  
  125.      $site->Apply(-dropcommand => $Y, $Y, 'XdndSelection');
  126.      $site->Apply(-entercommand => $X, $Y, 0);
  127.     }
  128.   }
  129.  my $data  = pack('LLLLL',oct($t->id),$sflags,0,0,0);
  130.  $t->SendClientMessage('XdndFinished',$src,32,$data);
  131. }
  132.  
  133. sub NoteSites
  134. {my ($class,$t,$sites) = @_;
  135.  if (@$sites)
  136.   {
  137.    $t->BindClientMessage('XdndLeave',[\&XdndLeave,$sites]);
  138.    $t->BindClientMessage('XdndEnter',[\&XdndEnter,$sites]);
  139.    $t->BindClientMessage('XdndPosition',[\&XdndPosition,$sites]);
  140.    $t->BindClientMessage('XdndDrop',[\&XdndDrop,$sites]);
  141.    $t->property('set','XdndAware','ATOM',32,[XDND_PROTOCOL_VERSION]);
  142.   }
  143.  else
  144.   {
  145.    $t->property('delete','XdndAware');
  146.   }
  147. }
  148.  
  149. 1;
  150. __END__
  151.